home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / eliza.com / ELIZA.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-12-26  |  9.0 KB  |  279 lines

  1. program Eliza;
  2.  
  3. {=========================================================}
  4. {      Keywords                                           }
  5. {=========================================================}
  6. const MaxKey = 37;
  7. type KeyWordArray = array[1..MaxKey] of string[14];
  8. const KeyWords : KeyWordArray = (
  9.                'CAN YOU','CAN I','YOU ARE','YOU''RE','I DON''T',
  10.                'I FEEL','WHY DON''T YOU','WHY CAN''T I','ARE YOU',
  11.                'I CAN''T','I AM','I''M','YOU','I WANT','WHAT',
  12.                'HOW','WHO','WHERE','WHEN','WHY','NAME','CAUSE',
  13.                'SORRY','DREAM','HELLO','HI','MAYBE','NO',
  14.                'YOUR','ALWAYS','THINK','ALIKE','YES','FRIEND',
  15.                'COMPUTER','NO KEY FOUND','REPEAT INPUT');
  16.  
  17. {=========================================================}
  18. {     Data for finding the right responses                }
  19. {=========================================================}
  20.  
  21. const RespFn = 'RESPONSE.DAT';   {response data file}
  22.       MaxRespNum = 116;
  23.  
  24. type KeyNumArray = array[1..MaxKey] of word;
  25.  
  26. var  RspIndex:KeyNumArray;  {- working response pointer array -}
  27.  
  28. {- this array contains the start index to the response strings -}
  29. const KeyIndex : KeyNumArray =
  30.         (1, 4, 6, 6,10,14,17,20,22,25,
  31.         28,28,32,35,40,40,40,40,40,40,
  32.         49,51,55,59,63,63,64,69,74,76,
  33.         80,83,90,93,99,106,113);
  34.  
  35. {- this array contains the end index to the response strings -}
  36. const KeyEnd : KeyNumArray =
  37.         (3, 5, 9, 9,13,16,19,21,24,27,
  38.         32,32,34,39,48,48,48,48,48,48,
  39.         50,54,58,62,68,63,68,73,75,79,
  40.         82,89,92,98,105,112,116);
  41.  
  42. {=========================================================}
  43. {      String data for conjugations                       }
  44. {=========================================================}
  45.  
  46. const MaxCon = 7;
  47. type ConStr = string[8];
  48.      ConjArray = array[1..MaxCon] of ConStr;
  49. const Con1 : ConjArray =
  50.     (' are ',' we''re ',' you ',' your ',' I''ve ',' I''m ',' me ');
  51.       Con2 : ConjArray =
  52.     (' am ',' was ',' I ',' my ',' you''ve ',' you''re ',' !you ');
  53.  
  54.  
  55. {=========================================================}
  56. {     Other misc information needed by the program        }
  57. {=========================================================}
  58.  
  59. {- possible punctuation -}
  60. const PuncSet = [' ','.','!','?',','];
  61.  
  62. {- misc error messages -}
  63. const NoFileMsg = 'Sorry, I seem to have mis-placed the response files.';
  64.       LogicErrMsg = 'Hmmm, I seem to be having problems myself.';
  65.  
  66.  
  67. {=========================================================}
  68. {  drop leading and trailing spaces and punctuation       }
  69. {=========================================================}
  70. procedure Ctrim(var Xstr:string);
  71. begin
  72.     while (length(Xstr) > 0) and (Xstr[1] in PuncSet) do
  73.       delete(Xstr,1,1);
  74.     while (length(Xstr) > 0) and (Xstr[length(Xstr)] in PuncSet) do
  75.       dec(Xstr[0]);
  76. end;
  77.  
  78. {=========================================================}
  79. {        return a string in upper case                    }
  80. {=========================================================}
  81. function UpCopy(Wstr:string; Pos,Cnt:byte):string;
  82. var Xstr:string;
  83.     i:integer;
  84. begin
  85.   Xstr[0] := #0;
  86.   for i := 1 to Cnt do
  87.   begin
  88.     inc(Xstr[0]);
  89.     Xstr[i] := upcase(Wstr[pred(Pos+i)]);
  90.   end;
  91.   UpCopy := Xstr;
  92. end;
  93.  
  94. {=========================================================}
  95. {        Find keyword in Wstr                             }
  96. {=========================================================}
  97. {- a keyword is a relational word that we can respond to }
  98. {- see the keyword table to see the types of relational words}
  99. {- that are used. Returns "Key" pointing to keyword in table,}
  100. {- returns "Kpos" pointing to first char after keyword in Wstr}
  101. {- Returns function true if keyword found, or false if not}
  102. {- if no keyword found Key = pred(MaxKey), repeated string = MaxKey}
  103.  
  104. function FindKey(Wstr:string; var Kpos,Key:word):boolean;
  105. var Xstr:string;
  106. label Found;
  107. begin
  108.   Xstr := UpCopy(Wstr,1,length(Wstr));
  109.   Key := 0;
  110.   while Key < pred(MaxKey) do
  111.   begin
  112.     inc(Key);
  113.     Kpos := pos(KeyWords[Key],Xstr);
  114.     if Kpos > 0 then goto Found;
  115.   end;
  116.   FindKey := false;
  117.   Exit;
  118.  
  119. Found:
  120.   Kpos := Kpos + Length(KeyWords[Key]);
  121.   FindKey := true;
  122. end;
  123.  
  124.  
  125. {=========================================================}
  126. {   Take the right part of the string and conjugate it    }
  127. {   using the list of strings to be swapped               }
  128. {=========================================================}
  129.  
  130. procedure Conjugate(var Wstr,Cstr:string; Kpos:word);
  131. var i,Cp:word;
  132.  
  133.   {- try to conjugate the string -}
  134.   function ConSwap(var Cs1,Cs2:ConStr):boolean;
  135.   begin
  136.     ConSwap := false;
  137.     if UpCopy(Cstr,Cp,length(Cs1)) = UpCopy(Cs1,1,length(Cs1)) then
  138.     begin
  139.       Cstr := copy(Cstr,1,pred(Cp))+Cs2+
  140.               copy(Cstr,Cp+length(Cs1),length(Cstr));
  141.       Cp := pred(Cp+length(Cs2));
  142.       ConSwap := true;
  143.     end
  144.   end;
  145.  
  146. {-procedure Conjugate-}
  147. begin
  148.     Cstr := copy(Wstr,Kpos,length(Wstr));    {pull out the right part}
  149.     Ctrim(Cstr);                             {clean it up}
  150.     if length(Cstr) = 0 then Cstr := Wstr;   {if empty use entire string}
  151.     Cstr := ' '+Cstr+' ';                    {add working spaces}
  152.  
  153.     for i := 1 to MaxCon do
  154.     begin
  155.       Cp := 0;
  156.       while Cp < length(Cstr) do
  157.       begin
  158.         inc(Cp);
  159.         if not(ConSwap(Con1[i],Con2[i])) then
  160.             if ConSwap(Con2[i],Con1[i]) then {nop};
  161.       end;
  162.     end;
  163.  
  164.     {- clean up the conjugated string -}
  165.     Cp := 1;
  166.     while Cp < length(Cstr) do
  167.       if Cstr[Cp] = '!' then Delete(Cstr,Cp,1) else inc(Cp);
  168.     Ctrim(Cstr);
  169.  
  170.     {- special case fixup for trailing 'I's -}
  171.     if Cstr[length(Cstr)] = 'I' then
  172.     begin
  173.       dec(Cstr[0]);
  174.       Cstr := Cstr+'me';
  175.     end;
  176. end;
  177.  
  178.  
  179. {============================================================}
  180. {        Reads a response from the response file             }
  181. {============================================================}
  182. procedure ReadResp(var Rstr:string; RespNum:word);
  183. var i:integer;
  184.     Respfile:text;
  185. label NoFileErr,LogicErr;
  186. begin
  187.   if (RespNum = 0) or (RespNum > MaxRespNum) then goto LogicErr;
  188.  
  189.   {- find the desired response in the response file -}
  190. {$I-}
  191.   assign(Respfile,RespFn);
  192.   reset(Respfile);
  193.   for i := 1 to pred(RespNum) do
  194.      Readln(Respfile);      {skip down to the desired response}
  195.   Readln(Respfile,Rstr);    {read it}
  196.   close(Respfile);          {and close the file}
  197. {$I+}
  198.   if IOResult <> 0 then goto NoFileErr;      {check for errors}
  199.   Exit;
  200.  
  201. {- couldn't find the file, or a read error occured -}
  202. NoFileErr:
  203.   Rstr := NoFileMsg;
  204.   Exit;
  205.  
  206. {- invalid response number given -}
  207. LogicErr:
  208.   Rstr := LogicErrMsg;
  209. end;
  210.  
  211.  
  212. {============================================================}
  213. { Get a response based on the keyword number in variable Key }
  214. {============================================================}
  215.  
  216. procedure GetResponse(var Rstr:string; Key:word);
  217. var Fstr:string;
  218. label QAppend,PAppend;
  219. begin
  220.   ReadResp(Fstr,RspIndex[Key]); {get the desired response from data file}
  221.  
  222.   {-Point to the next response so that no two are the same}
  223.   inc(RspIndex[Key]);
  224.   if RspIndex[Key] > KeyEnd[Key] then RspIndex[Key] := KeyIndex[Key];
  225.  
  226.   {-if no "*" or "@" at the end of the response, then just return the response}
  227.   {-if there was an "*" at the end of the response string, then return}
  228.   {-the response plus the conjugation word/phrase in Rstr plus a "?"}
  229.   {-if "@" then add a period instead}
  230.   if Fstr[length(Fstr)] = '*' then goto QAppend;
  231.   if Fstr[length(Fstr)] = '@' then goto PAppend;
  232.   Rstr := Fstr;
  233.   Exit;
  234.  
  235. {- replace the '*' with a space, append the conjugated string and add "?" -}
  236. QAppend:
  237.   Fstr[length(Fstr)] := ' ';
  238.   Rstr := Fstr+Rstr+'?';
  239.   Exit;
  240.  
  241. {- replace the '@' with a space, append the conjugated string and add "." -}
  242. PAppend:
  243.   Fstr[length(Fstr)] := ' ';
  244.   Rstr := Fstr+Rstr+'.';
  245. end;
  246.  
  247.  
  248. {============================================================}
  249. {- program Eliza -}
  250.  
  251. var Key,Kpos:word;          {- key word pointers -}
  252.     Istr,Pstr,Cstr:string;  {- operational strings -}
  253.  
  254. begin
  255.    RspIndex := KeyIndex; {- start the index array -}
  256.    writeln;
  257.    writeln('Hi! I''m Eliza. I am your personal therapy computer.');
  258.    writeln('Please tell me your problem.');
  259.    writeln;
  260.  
  261.    while true do
  262.    begin
  263.      readln(Istr);
  264.      Ctrim(Istr);   {- strip out any extra blanks from work string -}
  265.      Cstr := UpCopy(Istr,1,length(Istr));
  266.      if (Cstr = 'STOP') or (Cstr = 'QUIT') then Halt;
  267.  
  268.      Key := MaxKey;                   {- set max for repeat input -}
  269.      if Cstr <> Pstr then             {- get new key if not repeat -}
  270.        if FindKey(Cstr,Kpos,Key) then {- If keyword found in Istr -}
  271.           Conjugate(Istr,Cstr,Kpos);  {- then conjugate the string -}
  272.  
  273.      Pstr := UpCopy(Istr,1,length(Istr)); {- save original input string -}
  274.      GetResponse(Cstr,Key); {- Get response based on Keyword found -}
  275.      writeln(Cstr);         {- and print the response -}
  276.    end;
  277. end.
  278.  
  279.  
  280.